io Programmo 70/IOPROG_70.ISO/soft/Codice/Libro Allegato/progAvanzataWord.bas

BASIC Source File | 2003-05-02 | 11.1 KB | 348 lines

Attribute VB_Name = "progAvanzataWord"
Sub prendiLinks()
'---------------------------------------------------
' Visualizza gli elementi dell'insieme Hyperlinks
' del documento attivo e chiede al'utente se seguirli
' (applicando il metodo Follow) o meno
'---------------------------------------------------
' (c) 2003 Ivan Venuti e Marinella Lizza
'---------------------------------------------------

 Dim links As Word.Hyperlinks
 Set links = ActiveDocument.Hyperlinks
 For Each elemento In links
    With elemento
    risp = MsgBox( _
        "Address =" & vbTab & .Address & vbLf & _
        "TextToDisplay =" & vbTab & .TextToDisplay & vbLf & _
        "SubAddress =" & vbTab & .SubAddress & vbLf & _
        "Target =" & vbTab & vbTab & .Target & vbLf & _
        "Range =" & vbTab & vbTab & .Range & vbLf & VBA.vbLf & _
        "Eseguire il metodo follow?", vbYesNo, _
        "Link del documento")
    If risp = VBA.vbYes Then elemento.Follow
    End With
 Next
End Sub

Function inserisci(vettore() As String, elemento As String, max As Integer) As Integer
'---------------------------------------------------
' Scorre il vettore, che si suppone ordinato,
' e inserisce il nuovo elemento mantenendo
' l'ordinamento lessicografico
'---------------------------------------------------
' (c) 2003 Ivan Venuti e Marinella Lizza
'---------------------------------------------------
    MsgBox "Inserisci " & elemento
    indice = 0
    While indice < max And vettore(indice) < elemento
        indice = indice + 1
    Wend
    If indice = max Or vettore(indice) > elemento Then
        inserisci = 1
        For i = max To indice Step -1
            vettore(i + 1) = vettore(i)
        Next
        vettore(indice) = elemento
    Else
        inserisci = 0
    End If
End Function

Function collectEmailAddresses() As String()
'---------------------------------------------------
' Prende tutti gli indirizzi email dall'insieme
' Hyperlinks del documento attivo e li memorizza
' in ordine lessicografico in un vettore, eliminando
' eventuali indirizzi uguali.
' Restituisce il vettore.
'---------------------------------------------------
' (c) 2003 Ivan Venuti e Marinella Lizza
'---------------------------------------------------
    Dim indirizzi() As String
    Dim indiceMax As Integer
    Dim indice As Integer
    indiceMax = 1
    indice = 0
    ReDim indirizzi(indiceMax)
    ' reperisce solo gli indirizzi di email
    For Each elemento In ActiveDocument.Hyperlinks
        If (VBA.Left(elemento.Address, 7) = "mailto:") Then
            ' Φ prorpio un indirizzo di email
            incremento = inserisci(indirizzi, _
                VBA.Mid(elemento.Address, 8), indice)
            indice = indice + incremento
            If (indice >= indiceMax) Then
                ' E' necessario ridimensionare il vettore
                indiceMax = indiceMax * 2
                ReDim Preserve indirizzi(indiceMax)
            End If
        End If
    Next
    collectEmailAddresses = indirizzi
End Function



Sub folderEmailAddresses()
' Crea un nuovo folder di email i cui indirizzi sono
' gli indirizzi email contenuti nel documento attivo
'---------------------------------------------------
' (c) 2003 Ivan Venuti e Marinella Lizza
'---------------------------------------------------

    Dim applic As Outlook.Application
    Set applic = New Outlook.Application
    Dim folder As Outlook.MAPIFolder
    Dim space As Outlook.NameSpace
    Set space = applic.GetNamescape("MAPI")

    Dim indirizzi() As String
    indirizzi = collectEmailAddresses()
End Sub




Sub sendEmailAddresses()
'---------------------------------------------------
' Crea un nuovo folder di email i cui indirizzi sono
' gli indirizzi email contenuti nel documento attivo
'---------------------------------------------------
' (c) 2003 Ivan Venuti e Marinella Lizza
'---------------------------------------------------

    Dim applic As Outlook.Application
    Dim messaggio As Outlook.MailItem
    Set applic = New Outlook.Application
    Set messaggio = applic.CreateItem(olMailItem)
    Dim indirizzi() As String
    indirizzi = collectEmailAddresses()
    For Each elemento In indirizzi
        If (elemento <> "") Then
            messaggio.Recipients.Add elemento
        End If
    Next
    messaggio.Display
End Sub


Sub aggiungiBarraComandi()
'---------------------------------------------------
' Esempio di come creare una nuova barra di comandi
'---------------------------------------------------
' (c) 2003 Ivan Venuti e Marinella Lizza
'---------------------------------------------------
    Dim titolo As String
    Dim cb As CommandBar
    titolo = "Pulsantiera"
    On Error Resume Next
    Set cb = CommandBars.Item(titolo)
    If cb Is Nothing Then
        ' Non esiste: crea la barra dei comandi
        Err.Clear
        MsgBox "Creazione pulsantiera..."
        Set cb = CommandBars.Add(titolo)
        cb.Visible = True

        Dim cbc As CommandBarControl
        Set cbc = cb.Controls.Add()
        cbc.Style = msoButtonCaption
        cbc.Caption = "[ Invia @ ]"
        cbc.OnAction = "sendEmailAddresses"
        cbc.TooltipText = "Prendi indirizzi email"

        Set cbc = cb.Controls.Add()
        cbc.Style = Office.msoButtonCaption
        cbc.Caption = "[ Links ]"
        cbc.OnAction = "prendiLinks"
        cbc.TooltipText = "Prendi link"

        Set cbc = cb.Controls.Add()
        cbc.Style = Office.msoButtonCaption
        cbc.Caption = "[ X ]"
        cbc.OnAction = "elimina"
        cbc.TooltipText = "Elimina pulsantiera"
    Else
        ' Esiste giα: la rende comunque visibile
        cb.Visible = True
    End If
End Sub


Sub aggiungiBarraComandiBis()
'---------------------------------------------------
' Esempio di come creare una nuova barra di comandi
'---------------------------------------------------
' (c) 2003 Ivan Venuti e Marinella Lizza
'---------------------------------------------------
    Dim titolo As String
    Dim cb As CommandBar
    titolo = "Pulsantiera"
    On Error Resume Next
    Set cb = CommandBars.Item(titolo)
    If cb Is Nothing Then
        ' Non esiste: crea la barra dei comandi
        Err.Clear
        MsgBox "Creazione pulsantiera..."
        Set cb = CommandBars.Add(titolo)
        cb.Visible = True

        ' Primo pulsante
        Dim cbc As CommandBarControl
        Set cbc = cb.Controls.Add()
        cbc.Style = msoButtonCaption
        cbc.Caption = "[ Invia @ ]"
        cbc.OnAction = "sendEmailAddresses"
        cbc.TooltipText = "Prendi indirizzi email"

        ' Secondo pulsante
        Set cbc = cb.Controls.Add()
        cbc.Style = msoButtonCaption
        cbc.Caption = "[ Nuovo folder @ ]"
        cbc.OnAction = "folderEmailAddresses"
        cbc.TooltipText = "Prendi indirizzi email"

        ' Terzo pulsante
        Set cbc = cb.Controls.Add()
        cbc.Style = Office.msoButtonCaption
        cbc.Caption = "[ Links ]"
        cbc.OnAction = "prendiLinks"
        cbc.TooltipText = "Prendi link"

        ' Quarto pulsante
        Set cbc = cb.Controls.Add()
        cbc.Style = Office.msoButtonCaption
        cbc.Caption = "[ ? ]"
        cbc.OnAction = "Help"
        cbc.TooltipText = "Aiuto"

        ' Quinto pulsante
        Set cbc = cb.Controls.Add()
        cbc.Style = Office.msoButtonCaption
        cbc.Caption = "[ X ]"
        cbc.OnAction = "elimina"
        cbc.TooltipText = "Elimina pulsantiera"
    Else
        ' Esiste giα: la rende comunque visibile
        cb.Visible = True
    End If
End Sub

Sub elimina()
'---------------------------------------------------
' Elimina la barra creata
'---------------------------------------------------
' (c) 2003 Ivan Venuti e Marinella Lizza
'---------------------------------------------------

    On Error Resume Next
    Dim cb As CommandBar
    titolo = "Pulsantiera"
    Set cb = CommandBars(titolo)
    cb.Delete
End Sub

Sub Help()
'---------------------------------------------------
' Aiuto sulle funzionalitα
'---------------------------------------------------
' (c) 2003 Ivan Venuti e Marinella Lizza
'---------------------------------------------------
    MsgBox "Esempio di pulsantiera personalizzata"
End Sub


Sub applicaBubbleSort(StringArray() As String)
'---------------------------------------------------
' IMPLEMENTAZIONE ALGORITMO DI ORDINAMENTO
' BUBBLE SORT
'---------------------------------------------------
' (c) 2003 Ivan Venuti e Marinella Lizza
'---------------------------------------------------
  Dim a As String, b As String
  Dim scambio As Boolean
  Dim i As Integer
  Dim ultimo As Integer

  ultimo = UBound(StringArray)
  primo = LBound(StringArray)
  scambio = True

  While scambio
    scambio = False
    For i = primo To ultimo - 1
      a = StringArray(i)
      b = StringArray(i + 1)
      If a > b Then
        StringArray(i) = b
        StringArray(i + 1) = a
        scambio = True
      End If
    Next
    ultimo = ultimo - 1
 Wend
End Sub

Sub ordina()
'---------------------------------------------------
' Esempio di applicazione algoritmo di ordinamento
'---------------------------------------------------
' (c) 2003 Ivan Venuti e Marinella Lizza
'---------------------------------------------------
 Dim vettore(0 To 6) As String
 vettore(0) = "Ivan"
 vettore(1) = "Marinella"
 vettore(2) = "Alan"
 vettore(3) = "Roberto"
 vettore(4) = "Francesco"
 vettore(5) = "Ettore"
 vettore(6) = "Alberto"
 'applicaQuickSort vettore, 0, 6
 applicaBubbleSort vettore
 For i = 0 To 6
    MsgBox i & "> " & vettore(i)
 Next
End Sub


Sub applicaQuickSort(StringArray() As String, _
        estremoSx As Long, estremoDx As Long)
'---------------------------------------------------
' IMPLEMENTAZIONE ALGORITMO DI ORDINAMENTO
' QUICK SORT
'---------------------------------------------------
' (c) 2003 Ivan Venuti e Marinella Lizza
'---------------------------------------------------
    Dim cursoreSx As Long
    cursoreSx = estremoSx
    Dim cursoreDx As Long
    cursoreDx = estremoDx
    Dim perno As String
    perno = StringArray((estremoSx + estremoDx) \ 2)
    While (cursoreSx <= cursoreDx)
      While (StringArray(cursoreSx) < perno And cursoreSx < estremoDx)
         cursoreSx = cursoreSx + 1
      Wend
      While (perno < StringArray(cursoreDx) And cursoreDx > estremoSx)
         cursoreDx = cursoreDx - 1
      Wend
      If (cursoreSx <= cursoreDx) Then
         tmpSwap = StringArray(cursoreSx)
         StringArray(cursoreSx) = StringArray(cursoreDx)
         StringArray(cursoreDx) = tmpSwap
         cursoreSx = cursoreSx + 1
         cursoreDx = cursoreDx - 1
      End If
    Wend
    If (estremoSx < cursoreDx) Then
        ' Applica quick sort sul sotto-vettore 1
        applicaQuickSort StringArray, estremoSx, cursoreDx
    End If
    If (cursoreSx < estremoDx) Then
        ' Applica quick sort sul sotto-vettore 2
        applicaQuickSort StringArray, cursoreSx, estremoDx
    End If
End Sub